perm filename BEAMS.OLD[NEW,LCS] blob
sn#445302 filedate 1979-05-29 generic text, type T, neo UTF8
00100 C*** BEAMS, BMREAD ************
00200 SUBROUTINE BEAMS
00300 INTEGER UPDN
00400 COMMON R2,JAZ,CENTR,JBZ,RJQ(20),JQ(20) /STF/RSTFAC(8),RSTJ2
00500 1 /XRN/RN(1) /PTR/KWDS(1) /RNW/RNW /A2Z/LAA,LBB
00600 1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
00700 1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,IT,POS
00800 1 /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
00900 1 /LIMIT/LIMIT,ITEM,LL,IS,IX /DPY/ST(3900),RHY(100)
01000 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
01100 1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
01200 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
01300 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
01400
01500 IF(RMODE.GE.500)RETURN
01600 C NO BEAMS WHEN USING SUBR. 'EXTRA' *********
01700 INVT=-1
01800 LS=IS
01900 C SAVE PTR TO RN ARRAY FOR SLUR FEATURE AT 614 (AND TREM. FEATURE)
02000 JNTC=NTC
02100 J=0
02200 A=-1.
02300 DO 1125 K=1,IZ
02400 RHY(K)=0
02500 C MUST BE ZEROED TO AVOID CONFUSION AT C.2212
02600 IF(R(1,K).GT.2)GO TO 1125
02700 C GET BACK RHYTH. INFO IN P9 OF NOTES (FOR JDIF, COMPOSITE BEAMS)
02800 B=R(3,K)
02900 IF(A.EQ.B)GO TO 1125
03000 C SKIP CHORD NOTES.
03100 A=B
03200 J=J+1
03300 RHY(K)=V(J)
03400 1125 CONTINUE
03500 125 IF(REND.NE.0)GO TO 25
03600 REND=3
03700 25 DO 1500 K=1,72
03800 IF(INP(K).EQ.LBB)GO TO 22
03900 C B=AUTOMATIC BEAMS.
04000 IF(INP(K).EQ.ISTAR)GO TO 15
04100 1500 IF(INP(K).EQ.ISEMI)GO TO 500
04200 15 INP(72)=ISTAR
04300 GO TO 500
04400 C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
04500 CC22 CALL BEAMQ
04600 CC SUBROUTINE BEAMQ
04700 CC COMMON /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
04800 CC 1 /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
04900 CC 1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
05000 CC 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
05100 CC 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M
05200 22 REREAD F78F,A,RB,RC
05300 C TYPE '2B' OR '3B' ETC. FOR AUTOMATIC BEAMS. (2=DUPLE 3=TRIPLE)
05400 IF(IREAD.NE.-1)GO TO 2222
05500 A=RB
05600 RB=RC
05700 C IREAD=-1 WHEN READING SOS FILES. (=-2 WITH ET FILES.)
05800 2222 A=A/2.
05900 C '2'=1 '3'=1.5 '2B 3;' MEANS THERE'S A 3 NOTE PICK-UP.
06000 CS IF(STEM)STEM=0
06100 C STEM=10 OR 20 IF ALREADY SETUP IN NOTES
06200 N=0
06300 J=0
06400 INP(72)=ISTAR
06500
06600 GR=4./88.
06700 NN=0
06800 NX=0
06900 C NX IS REST COUNTER
07000 NZ=0
07100 NL=1
07200 NJ=0
07300 NR=1
07400 JV=0
07500 C JV IS VX COUNTER
07600 C=0
07700 B=A-.001
07800 IF(RB.EQ.0)GO TO 122
07900 J=RB
08000 C RB=NUM OF PICKUP ITEMS.*******(NTS AND RSTS - BUT NOT GRACE NTS.)*******
08100 B=-.001
08200 DO 222 K=1,J
08300 222 IF(V(K).NE.GR)B=B+ABS(V(K))
08400 C ABOVE FOUND VALUE OF PICKUPS
08500 122 X=ABS(V(NR))
08600 IF(X.NE.GR)GO TO 2122
08700 NN=NN+1
08800 GO TO 2022
08900 2122 C=C+X
09000 C ADD ON RHYTH VALUE -- IF NOT GRACE NOTES
09100 IF(V(NR).LT.0)N=N+1
09200 C FINDS RESTS AND GRACE NOTES (WE SKIP THEM)
09300 IF(C.GT.B)GO TO 822
09400 2022 IF(NR.EQ.IRHY)GO TO 422
09500 922 NR=NR+1
09600 CC IF(NOTAIL(V(NR-1)).LT.0)GO TO 322
09700 C NR=RIGHT SIDE OF BEAM, NL=LEFT
09800 GO TO 122
09900 822 IF(NR-NL-NN-N.GT.0)GO TO 322
10000 C IGNORE IF ONLY ONE NOTE FILLS UNIT
10100 722 IF(NR.EQ.IRHY)GO TO 422
10200 NN=0
10300 NJ=NJ+N
10400 NZ=NJ
10500 N=0
10600 NL=NR+1
10700 C PUSH AHEAD FOR NEXT BEAM
10800 622 B=B+A
10900 C UPDATE SPACE POINTER
11000 IF(C.GT.B)GO TO 622
11100 GO TO 922
11200 522 DO 1522 K=NL,NR-1
11300 IF(NOTAIL(V(K)).GE.0)GO TO 1522
11400 C NOW FOUND NON-BEAM NOTE
11500 IF(K.GT.NL+1)GO TO 5522
11600 JV=JV-2
11700 C FOUND NO BEAM FOR 1ST 2 NOTES.
11800 GO TO 6522
11900 5522 KN=K-1
12000 VX(JV)=KN-NREST(KN)
12100 6522 KN=K
12200 3522 KN=KN+1
12300 IF(KN.GE.NR)GO TO 722
12400 C ALL DONE, JUMP OUT
12500 DO 2522 JA=KN,NR
12600 2522 IF(NOTAIL(V(JA)).LT.0)GO TO 4522
12700 JA=NR+1
12800 4522 IF(JA.EQ.KN)GO TO 3522
12900 C NO BEAM FOR ONLY ONE NOTE!
13000 JV=JV+2
13100 VX(JV-1)=KN-NREST(KN)
13200 KN=JA-1
13300 VX(JV)=KN-NREST(KN)
13400 VX(JV)=JA-1
13500 KN=JA
13600 GO TO 3522
13700 1522 CONTINUE
13800 GO TO 722
13900
14000 C MAIN AUTO BEAM SECTION.
14100 322 DO 21 K=NL,NR-1
14200 C THIS LOOP FINDS FIRST NOTE OF BEAM.
14300 X=V(K)
14400 IF(X.LT.0)GO TO 21
14500 IF(X.EQ.GR)GO TO 21
14600 IF(NOTAIL(X).LT.0)GO TO 21
14700 C SKIP IF NOTE VAL. DOESN'T REQUIRE A TAIL
14800 JV=JV+2
14900 COUNTER FOR VX ARRAY (WHERE WE PUT BEAM'S NOTE NUMS.)
15000 VX(JV-1)=K-NREST(K)
15100 C FUNCT. NREST TELLS HOW MANY RESTS TO SUBTRACT
15200 GO TO 221
15300 21 CONTINUE
15400 C IF WE GET HERE, NO BEAM NOTES FOUND.
15500 GO TO 722
15600 221 DO 321 K=NR,NL,-1
15700 C THIS LOOP FINDS LAST NOTE OF BEAM.
15800 X=V(K)
15900 IF(X.LT.0)GO TO 321
16000 IF(X.EQ.GR)GO TO 321
16100 IF(NOTAIL(X).LT.0)GO TO 321
16200 VX(JV)=K-NREST(K)
16300 C NREST SUBTRACTS ALL INTERVENING RESTS
16400 IF(VX(JV).NE.VX(JV-1))GO TO 522
16500 CATCHES TRIPLET 1/8 TO TRIPLET 1/4, ETC.
16550 JV=JV-2
16600 GO TO 722
16800 321 CONTINUE
16900
17000 C NEXT FOR BEAMED GRACE NOTES
17100 422 N=0
17200 J=1
17300 1122 X=V(J)
17400 IF(X.LT.0)N=N+1
17500 NR=0
17600 IF(X.NE.GR)GO TO 1022
17700 NL=J
17800 DO 1222 K=J,IRHY
17900 X=V(K)
18000 IF(X.LT.0.OR.X.NE.GR)GO TO 1322
18100 C STOPS GRACE NOTE BEAM AT REST OR NON-GRACE
18200 1222 NR=K
18300 1322 IF(NR-NL.LE.0)GO TO 1022
18400 CALL BAUTO(JV,NL,NR,N)
18500 C UPDATE VX COUNTER
18600 NL=NL+1
18700 J=NR
18800 1022 J=J+1
18900 IF(J.LE.IRHY)GO TO 1122
19000
19100 1422 IF(JV.EQ.0)RETURN
19200 C NO BEAMS - SO GO BACK.
19300 DO 2822 K=JV+1,50
19400 C USES ONLY 68 SLOTS IN 'V'
19500 2822 VX(K)=0
19600 CC END
19700
19800 J=0
19900 GO TO 511
20000
20100 C ******* 1ST MAIN LOOP *********
20200 500 REREAD F78F,VX
20300 J=0
20400 IF(IREAD.EQ.-1)J=1
20500 C SKIPS LINE #S IN SOS FILES. (=-2 IS FOR ET FILES.)
20600 511 J=J+1
20700 N=VX(J)
20800 JMP=1
20900 JDIF=0
21000 505 L=0
21100 K=0
21200 C=0
21300 POS=-10.
21400 RN(8+IS)=0
21500 RN(9+IS)=0
21600 IT=0
21700 UPDN=0
21800 CS IF(JSTEM.LT.*****0)GO TO 503
21900 CS IF(STEM.EQ.0)GO TO 503
22000 C UPDN=2=STEMS DOWN, (SLUR DIP UP) =1, OPPOSITE.
22100 104 JA=J+1
22200 B=VX(JA)
22300 C THE 2ND NOTE (-=DIP DOWN ALWAYS; +100=UP ALWAYS, ORD.=AUTOMATIC)
22400 IF(B.LT.100)GO TO 512
22500 UPDN=2
22600 B=B-100
22700 IF(B.GT.100)B=100-B
22800 C TYPE -NUM OR 200+NUM FOR DIP DOWN.
22900 VX(JA)=B
23000 512 IF(B.LT.0)UPDN=1
23100 RN(9+IS)=0
23200 BRK=AMOD(VX(J),1.)*10.
23300 IF(BRK.EQ.0)GO TO 503
23400 C ADDS NUM TO BRACK. OR BEAM. ADD DESIRED .NUM TO 1ST NUM.(1.3=3)
23500 RN(9+IS)=BRK+.0001
23600 GO TO 5030
23700 503 IF(N.GT.0)GO TO 5031
23800 IT=-1
23900 CALL SLEND
24000 C -1= SLUR INTO 1ST NOTE.
24100 C SETS POS OF LFT SIDE (-10+9, THEN +2)
24200 GO TO 5060
24300 5031 IF(N.LE.JNTC)GO TO 5030
24400 C JNTC=NUM OF REAL NTS+1
24500 CALL SLEND
24600 C SLEND CHECKS ON END POINTS OF THIS STAFF
24700 GO TO 504
24800 5030 L=L+1
24900 502 K=K+1
25000 IF(R(1,K).NE.1.)GO TO 502
25100 C IS IT A NOTE?
25200 P=R(3,K)
25300 IF(P.EQ.POS)GO TO 502
25400 C SKIPS DBLSTPS
25500 POS=P
25600 IF(L.LT.N)GO TO 506
25700 IF(C.NE.0)GO TO 506
25800 IF(R(10,K).EQ.0)C=19.-R(5,K)
25900 C GET STEM DIR. OF 1ST NOTE ON MAIN STAFF
26000 506 IF(L.LT.N)GO TO 5030
26100 5060 IF(JMP.LT.0)GO TO 504
26200 C JMP=-1 MEANS END NOTE OF GROUP
26300 J=J+1
26400 NN=VX(J)
26500 C IF 2ND NUM IS .LE. 1ST , THEN 2-NOTE SLUR. (-1 GOES TO 1)
26600 IF(NN.EQ.0)NN=N+1
26700 IF(NN.EQ.0)NN=1
26800 IF(NN.LT.0)GO TO 5061
26900 IF(NN.LE.N)NN=N+1
27000 C FOR USE WITH AUTO-BEAMS OR DIP UP. 2-NOTE SLUR OR BEAM UP.
27100
27200 5061 MK=N
27300 N=NN
27400 CC N=IABS(NN)
27500 M=K
27600 JA=3
27700 JB=4
27800 KN=K
27900 RB=0
28000 GO TO 550
28100 504 RB=2
28200 IF(NN.LT.0)RB=-RB
28300 C DIP IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
28400 550 RN(JA+IS)=POS
28500 CX B=XNOTE(K)
28600 B=ZNOTE(K)
28700 C ZNOTE GETS HEIGHT AND CHECKS FOR NOTE ON OTHER STAFF/STEM DIR.
28800
28900 513 RN(JB+IS)=B+RB
29000 C MK=# OF 1ST NOTE, N=END NOTE NOW
29100 JMP=-JMP
29200 IF(JMP.GT.0)GO TO 1503
29300 C GO FIND RT. SIDE OF SLUR
29400 JA=6
29500 JB=5
29600 IF(N.LE.MK)N=MK+1
29700 C PICKS UP TYPO ERRORS
29800 GO TO 503
29900
30000 1503 RN(2+IS)=STAFF
30100 IF(NN.GE.0)GO TO 277
30200 IF(C.GT.0)GO TO 377
30300 277 IF(C.GE.0)GO TO 35
30400 IF(NN.LE.0)GO TO 35
30500 377 NN=-NN
30600
30700 CCCC35 RA=10.
30800 C RA WILL=# OF TAILS, KN=1ST NOTE, K=LAST ('MOD' FOR DOTTED NOTES.)
30900 35 RN(1+IS)=6
31000 JMAX=0
31100 IF(N-MK.EQ.1)JMAX=-1
31200 DMAX=100.
31300 UMAX=-DMAX
31400 C FOR AUTO. BEAMS
31500
31600 JB=0
31700 MB=0
31800 C MB=-1 =GRACE NOTES UNDER BEAMS.
31900 IF(ABS(R(4,KN)).GE.80.)MB=-1
32000 RDIF=0
32100 C JDIF AND RDIF ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
32200 JDIF=0
32300 DO 2 L=KN,K
32400 IF(R(1,L).NE.1)GO TO 2
32500 IF(JDIF.NE.0)GO TO 1212
32600 BB=RHY(L)
32700 IF(BB.LE.0)GO TO 1212
32800 IF(BB.EQ.4./88.)GO TO 1212
32900 IF(RDIF.NE.0)GO TO 2212
33000 RDIF=BB
33100 C NOW WE HAVE FIRST RHYTH. VALUE UNDER BEAM
33200 RA=AMOD(R(7,L),10.0)
33300 C RA WILL=# OF TAILS ON 1ST NOTE.
33400 GO TO 1212
33500 2212 IF(RDIF.EQ.BB)GO TO 1212
33600 JDIF=L
33700 KDIF=IS
33800 C FOUND A DIFF. RHYTH. UNDER BEAM
33900 CXCX1212 IF(R(10,L).NE.0)GO TO 2
34000 C SKIP NOTES ON ANOTHER STAFF.**************?????????????
34100 1212 BB=R(5,L)
34200 IF(BB.GE.10.)GO TO 12
34300 UPDN=-1
34400 NN=19-AA
34500 CHORDS WILL HAVE FIXED STEM DIRECTIONS ALWAYS
34600 GO TO 2
34700 C SKIPS NON-NOTES AND DBLSTPS
34800 12 IF(MB.LT.0)GO TO 10
34900 AA=BB
35000 RB=R(4,L)
35100 IF(ABS(RB).GE.80)GO TO 2
35200 C SKIPS GRACE NOTES
35300 GO TO 110
35400 10 RB=ZNOTE(L)
35500 CX10 RB=XNOTE(L)
35600 110 IF(RB.GT.UMAX)UMAX=RB
35700 IF(RB.LT.DMAX)DMAX=RB
35800 C FOR AUTO. BEAMS
35900 RB=AMOD(R(7,L),10.0)
36000 112 IF(RA.EQ.RB)GO TO 2
36100 JB=-1
36200 C FLAG FOR MIXED NUM. OF BEAMS
36300 IF(RB.GE.RA)GO TO 2
36400 IF(RB.NE.0)RA=RB
36500 2 CONTINUE
36600 C ABOVE FINDS SMALLEST # OF TAILS. NEXT FOR HGTS.
36700 C ABOVE IS POS.2
36800 IT=KN
36900 M=3
37000 203 IF(R(10,IT).EQ.0)GO TO 202
37100 IF(JSTEM.GT.IT)GO TO 202
37200 CS IF(STEM.LE.0)GO TO 202
37300 C=RNW
37400 IF(NN.LT.0)GO TO 206
37500 IF(R(5,IT).LT.20)GO TO 202
37600 C=-C
37700 GO TO 205
37800 206 IF(R(5,IT).GE.20)GO TO 202
37900 205 IF(ABS(R(4,IT)).GE.80.)C=C*.6
38000 C FOR MINI BEAMS
38100 RN(M+IS)=RN(M+IS)+C*RSTJ2
38200 202 IF(IT.NE.KN)GO TO 201
38300 IT=K
38400 M=6
38500 GO TO 203
38600
38700 C FOR EXTRA BEAMS WITH CHORDS. SAVE IT IN "IT"
38800 201 IF(JSTEM.LE.IT)GO TO 577
38900 CS201 IF(STEM.GT.0)GO TO 577
39000 C *****↑↑↑↑↑↑ ABOVE WAS ".NE." BEFORE 4/30/76. WHY?#@&Xαε
39100 IF(UPDN.NE.0)GO TO 577
39200 NN=-1
39300 IF(UMAX+DMAX.LT.14)NN=-NN
39400 C SETS AUTO. BEAMS' STEM DIRECTION.
39500 577 X=10
39600 IF(NN.LT.0)X=20
39700 IF(MB.LT.0)RA=2
39800 C 2 BEAMS ON GRACE NOTES ALWAYS
39900 X=X+RA
40000 C # OF BEAMS. IT'S PUT IN DOWN BELOW 550.
40100 200 M=KN
40200 207 L=M+1
40300 IF(R(1,L).NE.1)GO TO 307
40400 IF(R(5,L).GE.10)GO TO 307
40500 M=M+1
40600 GO TO 207
40700 C FOR HEIGHTS OF DBL STPS, ETC.
40800 307 CONTINUE
40900 CX607 A=XNOTE(M)
41000 607 A=ZNOTE(M)
41100 C A=NOTE 1.
41200 UMAX=A
41300 DMAX=A
41400 C UP MAX. NOTE #, DOWN MAX. NOTE #.
41500 407 M=K+1
41600 IF(R(1,M).NE.1)GO TO 103
41700 CC IF(R(9,M).NE.0)GO TO 103
41800 IF(R(5,M).GE.10)GO TO 103
41900 C FINDS DBL+ STP ON LAST OF BEAM
42000 IF(R(6,M))GO TO 103
42100 C JUMP OUT IF A WHITE NOTE
42200 K=M
42300 GO TO 407
42400 103 IF(JSTEM.GT.KN)GO TO 604
42500 C FLAG IS SET (NR) IF STEMS ARE SPECIFIED IN DIFF. DIRECTIONS. (GRACE NTS??)
42600 604 NR=0
42700
42800 603 DO 3 M=KN,K
42900 IF(R(1,M).NE.1)GO TO 3
43000 CXCXCX IF(STEM.NE.0.AND.R(10,M).NE.0)GO TO 3
43100 C SKIP NOTES ON OTHER STAFF
43200 IF(M.EQ.K)GO TO 107
43300 IF(R(1,M+1).NE.1)GO TO 107
43400 C IT ONLY CARES ABOUT NOTES!
43500 IF(R(5,M+1).LT.10)GO TO 3
43600 C IGNORE LOWER (OR UPPER) NOTES OF CHORDS (NO STEM)-IN RE. UP-DOWN FEATURE.
43700 107 IF(MB.LT.0)GO TO 7
43800 C SKIP IF DEALING WITH GRACE NOTE BEAMS. (MB=-1)
43900 IF(ABS(R(4,M)).GE.100)GO TO 3
44000 C SKIPS NON-NOTES
44100 CX7 B=XNOTE(M)
44200 7 B=ZNOTE(M)
44300 CX677 IF(JSTEM.LE.M.AND.R(10,M).NE.0)GO TO 55
44400 CYY677 IF(JSTEM.LE.M)GO TO 55
44500 677 IF(JSTEM.LE.KN)GO TO 55
44600 C IGNORE STEM DIR. IF ALREADY SPECIFIED WITHIN THIS GROUP
44700 AA=R(5,M)
44800 IF(AA.LT.10.)GO TO 3
44900 STMDR=AA
45000 IF(NN.GT.0)GO TO 5
45100 C JUMP IF STEM UP
45200 IF(STMDR.GE.20.)GO TO 55
45300 IF(STMDR.LT.10.)GO TO 55
45400 R(5,M)=STMDR+10.
45500 GO TO 551
45600 5 IF(STMDR.LT.20.)GO TO 55
45700 R(5,M)=STMDR-10.
45800 C************************
45900 C STEM UP
46000 551 INVT=0
46100 55 IF(B.LT.UMAX)GO TO 13
46200 CC55 IF(B.LE.UMAX)GO TO 13
46300 C ↑↑↑↑↑↑↑↑ WAS .LT. !!!!! 5/76
46400 UMAX=B
46500 IF(JMAX.LT.0)GO TO 3
46600 IF(M.EQ.KN)GO TO 3
46700 IF(M.EQ.K)GO TO 3
46800 UMAX=UMAX+1
46900 GO TO 3
47000 13 IF(B.GT.DMAX)GO TO 3
47100 DMAX=B
47200 IF(JMAX.LT.0)GO TO 3
47300 IF(M.EQ.KN)GO TO 3
47400 IF(M.NE.K)DMAX=DMAX-1
47500 3 CONTINUE
47600 C LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
47700 C*************************************
47800
47900 4 K=IT
48000 C FOR EXTRA BEAMS WITH CHORDS. K WAS SAVED IN "IT"
48100 AA=A
48200 BB=B
48300 C=1
48400 IF(X.LT.20.)GO TO 48
48500 C JUMP IF STEM IS UP
48600 CALL EXCH(AA,BB)
48700 C=-C
48800 CALL EXCH(UMAX,DMAX)
48900 48 IF(AA.LT.BB)GO TO 45
49000 IF(UMAX.EQ.A)GO TO 46
49100 47 A=UMAX-C
49200 B=A
49300 GO TO 444
49400 46 IF(UMAX.GT.AA)GO TO 47
49500 GO TO 49
49600 45 IF(UMAX.NE.B)GO TO 47
49700 49 A=AA
49800 B=BB
49900 IF(X.GE.20)CALL EXCH(A,B)
50000
50100 444 RN(2+IS)=STAFF
50200 446 DIS=(RN(IS+6)-RN(IS+3))/6.
50300 C FOR TILT LATER --
50400 IF(ABS(A-B).LT.DIS)GO TO 143
50500 C=C*DIS
50600 C NEW TILT ROUTINE. CONSIDERS DISTANCE:HEIGHT
50700 C LIMITS SLOPE OF BEAM
50800 IF(X.GE.20)GO TO 141
50900 IF(B.GT.A)GO TO 140
51000 142 B=A-C
51100 GO TO 143
51200 141 IF(B.GT.A)GO TO 142
51300 140 A=B-C
51400
51500 CC143 BB=A
51600 CC143 IF(STMDR.GE.20)GO TO 530
51700 143 IF(X.GE.20)GO TO 530
51800 CC IF(B.LT.A)BB=B
51900 C BB IS LOWEST SIDE OF BEAM
52000 CC IF(BB.GE.0)GO TO 14
52100 C BEAM WILL ALWAYS TOUCH MIDDLE LINE OF STAFF
52200 CC BB=-BB
52300 IF(A.LT.0)A=0
52400 IF(B.LT.0)B=0
52500 GO TO 14
52600 530 IF(A.GT.14)A=14
52700 IF(B.GT.14)B=14
52800 C GETS NEW HEIGHT NUMBERS.
52900
53000 14 IF(MB.EQ.0)GO TO 330
53100 C NEXT FOR GRACE NOTE BEAMS (MB=-1)
53200 C=100
53300 IF(A.LT.0)C=-C
53400 A=A+C
53500 330 C=AMOD(X,10.0)-2
53600 IF(C.LE.0)GO TO 331
53700 C NEXT PUSHES OUT BEAMS IF 3 OR MORE.
53800 C=C+1
53900 IF(NN.LT.0)C=-C
54000 A=A+C
54100 B=B+C
54200 331 RN(4+IS)=A
54300 RN(5+IS)=B
54400 C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
54500 C*******?????? RN(6+IS)=R(3,K)
54600 C ABOVE IS POS.2
54700 C NEXT TO FIND TREMOLOS WHICH SHOULD BE PARALLEL TO BEAM.
54800 JA=IX
54900 AA=RN(IS+3)
55000 BB=RN(IS+6)
55100 300 IF(JA.GE.LS)GO TO 510
55200 C LS IS PTR TO RN ARRAY BEFORE BEAMS WERE ADDED.
55300 IF(RN(JA+1).EQ.6)GO TO 1300
55400 2300 JA=RN(JA)+JA+3
55500 C PUSH PTR AHEAD
55600 GO TO 300
55700 1300 C=RN(JA+3)
55800 IF(C.LT.AA.OR.C.GT.BB)GOTO 2300
55900 C NOW WE'VE FOUND TREM. WITHIN RANGE OF CURRENT BEAM.
56000 RN(JA+9)=C
56100 RN(JA+3)=AA
56200 RN(JA+6)=BB
56300 RN(JA+4)=A
56400 RN(JA+5)=B
56500 C=RN(JA+7)
56600 IF(C.GT.-20.)GO TO 3300
56700 IF(X.LT.20.)C=C+10
56800 GO TO 4300
56900 3300 IF(X.GE.20)C=C-10
57000 4300 RN(JA+7)=C
57100 C X=P7 INFO FOR CURRENT BEAM. (STEM DIR., NUM. OF BEAMS.)
57200 RN(JA+10)=ABS(AMOD(X,10.0))
57300 GO TO 2300
57400
57500 C ***********KN = 1ST NOTE, K=LAST NOTE.********
57600 510 M=R(5,KN)/10.0
57700 RN(7+IS)=M*10+AMOD(X,10.0)
57800 RN(10+IS)=0
57900 RN(IS+11)=-1
58000 CALL UPDATE(9)
58100 JA=IS
58200 C************************************** BMX ***********
58300 IF(JB.LT.0)CALL BMX(RA)
58400 IF(JA.NE.IS)GO TO 514
58500 IF(JDIF.EQ.0)GO TO 514
58600 C FOR NEW COMPOSITE BEAM FEATURE 4/78
58700 IF(RA.EQ.1)GO TO 514
58800 RN(7+KDIF)=X-1
58900 RN(10+KDIF)=100
59000 DO 515 K=JDIF-1,1,-1
59100 C LOOK FOR INTERVENING GRACE NOTES OR RESTS.
59200 N=K
59300 IF(R(1,K).NE.1)GO TO 515
59400 IF(R(8,K).EQ.1000.)GO TO 515
59500 N=K
59600 GO TO 516
59700 515 CONTINUE
59800 516 RN(8+KDIF)=R(3,N)
59900 RN(9+KDIF)=R(3,JDIF)
60000 A=R(3,N)
60100 B=R(3,JDIF)
60200 IF(A.EQ.RN(3+KDIF))A=A+2.4
60300 IF(B.EQ.RN(6+KDIF))B=B-2.4
60400 CREATES PARTIAL BEAM IF NECESSARY. (I.E. THERE'S A REST INVOLVED.)
60500 RN(8+KDIF)=A
60600 RN(9+KDIF)=B
60700
60800 514 J=J+1
60900 A=VX(J)
61000 N=A
61100 C SO ITEMS NEED NOT BE IN RIGHT ORDER.
61200 IF(MOD(N,100).GT.IRHY)A=0
61300 IF(A.NE.0)GO TO 505
61400 IF(J.LT.50)GO TO 514
61500 C SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
61600 614 IF(INP(72).NE.ISTAR)GO TO 552
61700
61800 714 IF(INVT)RETURN
61900 INVT=IS
62000 CALL NEWR
62100 IS=INVT
62200 RETURN
62300 552 CALL BMREAD
62400 C TO READ MORE THAN 2 LINES.
62500 GO TO 25
62600 END
62700
62800 SUBROUTINE BMREAD
62900 COMMON /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
63000 1 /IDEV/IDEV
63100 552 IF(IREAD.NE.0)GO TO 3501
63200 CALL TYPE
63300 IF(IDEV.EQ.5)WRITE(21,4501)INP
63400 GO TO 1
63500 3501 IF(IREAD.EQ.-1)READ(22,2501)J,INP
63600 IF(IREAD.EQ.-2)READ(22,4501)INP
63700 C FOR 2ND LINE.
63800 CALL TYPOUT
63900 1 CALL LNEND
64000 CALL LULOOP
64100 C CHANGE LOWER CASE TO UPPER.
64200 4501 FORMAT(72A1)
64300 2501 FORMAT(I,72A1)
64400 END
64500